home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / misc / foreign.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  4.1 KB  |  122 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;; -*- Mode: Lisp;  -*-
  5. ;;; File: foreign-interface.lisp
  6. ;;; Author: Paul Viola (viola@ai.mit.edu)
  7. ;;; Copyright (C) Paul Viola, 1993
  8. ;;;*----------------------------------------------------------------------------
  9. ;;;* FUNCTION: Code to support foreign function call interface in GCL.
  10. ;;;*
  11. ;;;* CLASSES:
  12. ;;;* 
  13. ;;;* RELATED PACKAGES:
  14. ;;;*
  15. ;;;* HISTORY:
  16. ;;;* Last edited: May  7 17:55 1993 (viola)
  17. ;;;* Created: Thu May  6 11:36:49 1993 (viola)
  18. ;;;*----------------------------------------------------------------------------
  19.  
  20. (in-package "USER")
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ;;; Code that makes some lucid foreign function definitions work in GCL.
  24.  
  25. (defparameter *lucid-to-gcl-c-types*
  26.   '((:signed-32bit int)
  27.     (:unsigned-32bit int)        ;I hope this is right.
  28.     (:double-float double)
  29.     (:single-float float)
  30.     (:simple-string string)
  31.     ((:pointer :signed-32bit) vector-int)
  32.     ((:pointer :single-float) vector-single-float)
  33.     ((:pointer :double-float) vector-double-float)
  34.     (:null void)))
  35.  
  36. (defmacro def-foreign-function ((lisp-name . key-params) . c-params)
  37.   "I wrote this so that lucid calls to foreign functions could be used directly in
  38. GCL. "
  39.   (progn (print lisp-name)
  40.      `(defentry-2 ,lisp-name
  41.        ,(loop for param in c-params
  42.           collect (cadr (assoc (cadr param) *lucid-to-gcl-c-types*
  43.                        :test #'equal)))
  44.        ,(list (cadr (assoc (lucid-return-type key-params) *lucid-to-gcl-c-types*
  45.                    :test #'equal))
  46.           (lucid-c-name key-params)))))
  47.  
  48. (defun lucid-return-type (key-params)
  49.   (cadar (member :return-type key-params :key #'car)))
  50.  
  51. (defun lucid-c-name (key-params)
  52.   (intern
  53.    (string-upcase
  54.     (subseq (cadar (member :name key-params :key #'car)) 1))))
  55.  
  56. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57. ;;; Using lisp strings in C is a pain.  First they need to be NULL terminated
  58. ;;; then they need to be converted into a C object.  The code below returns a
  59. ;;; C-string from a lisp routine.  This is pretty dangerous - I don't know what
  60. ;;; would happen if you tried to operate on it.
  61.  
  62. ;;; For an array of ints.
  63. (defCfun "object get_c_ints(s) object s;" 0
  64.   " return(s->fixa.fixa_self);"
  65.   )
  66.  
  67. (defentry get-c-ints (object) (object get_c_ints))
  68.  
  69. ;;; For an array of single-floats.
  70. (defCfun "object get_c_single_floats(s) object s;" 0
  71.   " return(s->sfa.sfa_self);"
  72.   )
  73.  
  74. (defentry get-c-single-floats (object) (object get_c_single_floats))
  75.  
  76. ;;; For an array of double-floats.
  77. (defCfun "object get_c_double_floats(s) object s;" 0
  78.   " return(s->lfa.lfa_self);"
  79.   )
  80.  
  81. (defentry get-c-double-floats (object) (object get_c_double_floats))
  82.  
  83. ;;; For a string.
  84. (defCfun "object get_c_string(s) object s;" 0
  85.   " return(s->st.st_self);"
  86.   )
  87. (defentry get_c_string_2 (object) (object get_c_string))
  88.  
  89. ;; make sure string is null terminated
  90. (defun get-c-string (string)
  91.   (get_c_string_2 (concatenate 'string string "
  92.  
  93.  
  94. (defparameter *gcl-to-c-types*
  95.   '((int int nil)
  96.     (char char nil)
  97.     (float float nil)
  98.     (double double nil)
  99.     (object object nil)
  100.     (string object get-c-string)
  101.     (vector-int object get-c-ints)
  102.     (vector-single-float object get-c-single-floats)
  103.     (vector-double-float object get-c-double-floats)))
  104.         
  105. (defmacro defentry-2 (func-name param-types declaration)
  106.   "Macro enhances defentry so that composite types can be passed to C functions.
  107. For a list of types look at *gcl-to-c-types*"
  108.   (let ((f-name (intern (concatenate 'string (symbol-name func-name) "-2")))
  109.     (new-types (mapcar #'(lambda (a) (cadr (assoc a *gcl-to-c-types*))) param-types))
  110.     (param-list (mapcar #'(lambda (a) (gensym)) param-types)))
  111.     `(progn 
  112.       (defentry ,f-name ,new-types ,declaration)
  113.       (defmacro ,func-name ,param-list
  114.     (list ',f-name
  115.           ,@(loop for p in param-list
  116.               for type in param-types
  117.               for (ntype new-type converter-func) = (assoc type *gcl-to-c-types*)
  118.               collect (if (null converter-func)
  119.                   p
  120.                   `(list ',converter-func ,p))))))))
  121.  
  122.